home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / t3_1 / risc_src.lha / risc_sources / sys / string_buf.t < prev    next >
Text File  |  1989-06-30  |  5KB  |  143 lines
  1. (herald string_buffer (env tsys))
  2.  
  3. ;;; Copyright (c) 1985 Yale University
  4. ;;;     Authors: N Adams, R Kelsey, D Kranz, J Philbin, J Rees.
  5. ;;; This material was developed by the T Project at the Yale University Computer 
  6. ;;; Science Department.  Permission to copy this software, to redistribute it, 
  7. ;;; and to use it for any purpose is granted, subject to the following restric-
  8. ;;; tions and understandings.
  9. ;;; 1. Any copy made of this software must include this copyright notice in full.
  10. ;;; 2. Users of this software agree to make their best efforts (a) to return
  11. ;;;    to the T Project at Yale any improvements or extensions that they make,
  12. ;;;    so that these may be included in future releases; and (b) to inform
  13. ;;;    the T Project of noteworthy uses of this software.
  14. ;;; 3. All materials developed as a consequence of the use of this software
  15. ;;;    shall duly acknowledge such use, in accordance with the usual standards
  16. ;;;    of acknowledging credit in academic research.
  17. ;;; 4. Yale has made no warrantee or representation that the operation of
  18. ;;;    this software will be error-free, and Yale is under no obligation to
  19. ;;;    provide any services, by way of maintenance, update, or otherwise.
  20. ;;; 5. In conjunction with products arising from the use of this material,
  21. ;;;    there shall be no use of the name of the Yale University nor of any
  22. ;;;    adaptation thereof in any advertising, promotional, or sales literature
  23. ;;;    without prior written consent from Yale in each case.
  24. ;;;
  25.  
  26. ;;; describe buffers
  27.  
  28. ;++ what should be integrated?
  29. ;++ pooled structures
  30.  
  31. (define-integrable (string-buffer-limit b)
  32.   (text-length (string-text b)))
  33.  
  34. (define-integrable (string-buffer-space-remaining b)
  35.   (fx- (string-buffer-limit b) (string-length b)))
  36.  
  37. (define-integrable string-buffer->string copy-string)
  38. (define-integrable string-buffer-length  string-length)
  39.  
  40. ;++ Should this be lap? or primop. This uses indexing, on a machine
  41. ;++ with tags it would use pointers into objects.
  42.  
  43. ;(define-integrable (MOVE-TEXT SRC S-OFF DST D-OFF N)
  44. ;  (do ((n n (fx- n 1))
  45. ;       (s-off s-off (fx+ s-off 1))
  46. ;       (d-off d-off (fx+ d-off 1)))
  47. ;      ((fx<= n 0) (no-value))
  48. ;    (set (text-elt dst d-off) (text-elt src s-off))))
  49.  
  50. ;;; Makes sure that buffer can hold at least N additional characters.
  51. ;;; If not the buffers size in increased by allocating a buffer
  52. ;;; of the appropriate size, copying the contents of the old buffer
  53. ;;; to the new, and finally exchanging the text pointers of the
  54. ;;; two buffers, hopefully, creating a transparent side effect.
  55.  
  56. (define (ensure-string-buffer-size b n)
  57.   (cond ((fx< (string-buffer-space-remaining b) n)
  58.          (let* ((old-size (string-length b))
  59.                 (temp     (get-string-buffer-of-size (fx+ old-size n))))
  60.            (move-text (string-text b) 0 (string-text temp) 0 old-size)
  61.            (exchange (string-text b) (string-text temp))
  62.            (release-string-buffer temp))))
  63.   (no-value))
  64.  
  65. ;;; Write a character to a buffer.
  66.  
  67. (define (string-writec b ch)
  68.   (let ((len (string-length b)))
  69.     (let ((new-len (fx+ len 1)))
  70.       (if (fx>= new-len *min-string-buffer-size*) ; horrible speed hack
  71.           (ensure-string-buffer-size b 1))
  72.       (set (string-length b) new-len)
  73.       (set (text-elt (string-text b) len) ch)))
  74.   (no-value))
  75.  
  76. ;;; Write a string to a buffer.
  77.  
  78. (define (string-writes b s)
  79.   (let* ((slen    (string-length s))
  80.          (blen    (string-length b))
  81.          (new-len (fx+ blen slen)))
  82.     (if (fx>= new-len *min-string-buffer-size*) ; horrible speed hack
  83.         (ensure-string-buffer-size b slen))
  84.     (move-text (string-text s) 0 (string-text b) blen slen)
  85.     (set (string-length b) new-len))
  86.   (no-value))
  87.  
  88. ;;; Obtain a buffer.
  89.  
  90. (define (get-string-buffer)
  91.   (let ((b (obtain-from-pool (vref *string-buffer-pools* 0))))
  92.     (set (string-length b) 0)
  93.     b))
  94.  
  95. ;;; Obtain a buffer whose size is >= N.
  96.  
  97. (define (get-string-buffer-of-size n)
  98.   (let ((b (obtain-from-pool (string-buffer-pool n))))
  99.     (set (string-length b) 0)
  100.     b))
  101.  
  102. ;;; Release a buffer.
  103.  
  104. (define (release-string-buffer b)
  105.   (let ((b (enforce string? b)))
  106.     (return-to-pool (string-buffer-pool (string-buffer-limit b)) b)))
  107.  
  108.  
  109. ;++ This should be an abstraction in pool.
  110. ;;; There are ten pools, for buffers of various sizes.
  111. ;;;    0    1    2    3     4     5     6     7      8      9
  112. ;;;   64  128  256  512  1024  2048  4096  8192  16834  32768
  113.  
  114. (define *string-buffer-pools* (make-vector 10))
  115.  
  116. (define-constant *min-string-buffer-size* 64)
  117. (define-constant *max-string-buffer-size* 32768)
  118.  
  119. (define (initialize-string-buffer-pool)
  120.   (do ((i 0 (fx+ i 1))
  121.        (n *min-string-buffer-size* (fixnum-ashl n 1)))
  122.       ((fx> i 9))
  123.     (set (vref *string-buffer-pools* i)
  124.          (make-pool `(*string-buffer-pool* ,i)
  125.                      (lambda () (make-string n))
  126.                      1
  127.                      string?))))
  128.                                                         
  129. ;;; Return a pool from which one can obtain a buffer whose size
  130. ;;; is >= N.
  131.  
  132. (define (string-buffer-pool n)
  133.   (cond ((fx<= n *min-string-buffer-size*)
  134.          (vref *string-buffer-pools* 0))       ; speed hack for common case
  135.         (else
  136.          (let ((i (fixnum-howlong (fixnum-ashr (fx- n 1) 6))))
  137.            (if (fx> n *max-string-buffer-size*)
  138.                (error "cannot allocate buffer of size ~a~%" n)
  139.                (vref *string-buffer-pools* i))))))
  140.  
  141.  
  142. (initialize-string-buffer-pool)
  143.